COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	scheme[f82,jmc]		scheme hairy control structure for samefringe
C00005 ENDMK
C⊗;
scheme[f82,jmc]		scheme hairy control structure for samefringe

(define fringe
	(lambda (tree)
		(labels ((fringen
			  (lambda (node alt)
				  (lambda (getter)
					  (if (atom node)
					      (getter node alt)
					      ((fringen (car node)
							(lambda (getter1)
								((fringen
								  (cdr node)
								  alt)
								 getter1)))
					       getter))))))
			(fringen tree
				 (lambda (getter)
					 (getter '(exhausted) nil))))))

(define samefringe
	(lambda (tree1 tree2)
		(labels ((same
			  (lambda (s1 s2)
				  (s1 (lambda (x1 r1)
					      (s2 (lambda (x2 r2)
							  (if (equal x1 x2)
							      (if (equal
								   x1
								   (exhausted))
								  t
								  (same r1 r2))
							      nil))))))))
			(same (fringe tree1)
			      (fringe tree2)))))

;;; the less hairy version

(define fringe
	(lambda (tree)
		(labels ((fringe1
			  (lambda (node alt)
				  (if (atom node)
				      (lambda (msg)
					      (if (eq msg 'first) node
						  (if
						   (eq msg 'next)
						   (alt)
						   (error))))
				      (fringe1 (car node)
					       (lambda ()
						       (fringe1 (cdr node) alt)))))))
			(fringe1 tree
				 (lambda ()
					 (lambda (msg) (if (eq msg 'first)
							   '*eof*
							   (error))))))))

(define samefringe
	(lambda (t1 t2)
		(do ((c1 (fringe t1) (c1 'next))
		     (c2 (fringe t2) (c2 'next)))
		    ((or (not (eq (c1 'first) (c2 'first)))
			 (eq (c1 'first) '*eof*)
			 (eq (c2 'first) '*eof*))
		     (eq (c1 'first) (c2 'first)))))